Dr. Windows 3/dr win3.zip/dr win3/UTILITY1/MSWLGO35.ZIP/EXAMPLES/PASCAL

Text File | 1993-04-11 | 23KB | 909 lines

;
; Function:
;
; Pascal Compiler
;
; To run:
;
; Load "pascal
; Call COMPILE "module.pas ! (module on disk)
; Call PRUN "module
;
; It's slow but it works.
;

TO BUGFIX :VAL
OP INT :VAL
END
;;; All references to BUGFIX are because products aren't integers on the Mac

TO ACOUNT :ARRAY
OUTPUT COUNT :ARRAY
END

TO GARRAY :ARRAY :INDEX
OP ITEM BUGFIX :INDEX+1 :ARRAY
END

TO PARRAY :ARRAY :INDEX :VALUE
SETITEM BUGFIX :INDEX+1 :ARRAY :VALUE
END

TO ARGLIST
LOCAL [NAMES TYPE VARFLAG]
MAKE "VARFLAG "FALSE
IFBE "VAR [MAKE "VARFLAG "TRUE]
MAKE "NAMES COMMALIST [ID]
MUSTBE ":
MAKE "TYPE TOKEN
IF EQUALP :TYPE "PACKED [MAKE "TYPE TOKEN]
IFELSE EQUALP :TYPE "ARRAY [MAKE "TYPE ARRAYTYPE] [TYPECHECK :TYPE]
FOREACH :NAMES [NEWARG ? :TYPE NEWLNAME ? :VARFLAG]
IFBEELSE "|;| [ARGLIST] [MUSTBE "|)|]
END

TO ARRAYCOPY :TOTARGET :FROMTARGET
LOCAL [TO FROM]
MAKE "TO THING FIRST :TOTARGET
MAKE "FROM THING FIRST :FROMTARGET
FOR [I 0 [(ACOUNT :FROM) - 1]] [PARRAY :TO :I GARRAY :FROM :I]
END

TO ARRAYSIZE :TYPE
OUTPUT BUGFIX REDUCE "PRODUCT MAP [LAST ?] LAST :TYPE
END

TO ARRAYTYPE
LOCAL [RANGES TYPE]
MUSTBE "|[|
MAKE "RANGES COMMALIST [RANGE]
MUSTBE "|]|
MUSTBE "OF
MAKE "TYPE TOKEN
TYPECHECK :TYPE
OUTPUT LIST :TYPE :RANGES
END

TO BLOCK
LOCAL [BLOCKNAME CODEINTO]
MAKE "BLOCKNAME GENSYM
DEFINE :BLOCKNAME [[]]
MAKE "CODEINTO :BLOCKNAME
BLOCKBODY "END
OUTPUT (LIST :BLOCKNAME)
END

TO BLOCKBODY :ENDWORD
CODE STATEMENT
IFBEELSE "|;| [BLOCKBODY :ENDWORD] [MUSTBE :ENDWORD]
END

TO BOOLTOINT :EXPR
OUTPUT (SE [( IFELSE] :EXPR [[1] [0] )])
END

TO CHARTOINT :EXPR
OUTPUT (SE [( ASCII FIRST BF] :EXPR [)] )
END

TO CHARTOPRINT :CHARVAL
OUTPUT FIRST BF :CHARVAL
END

TO CODE :STUFF
IF EMPTYP :STUFF [STOP]
DEFINE :CODEINTO LPUT :STUFF TEXT :CODEINTO
END

TO COMMALIST :TEST [:SOFAR []]
LOCAL [RESULT TOKEN]
MAKE "RESULT RUN :TEST
IF EMPTYP :RESULT [OUTPUT :SOFAR]
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN ", [OUTPUT (COMMALIST :TEST (LPUT :RESULT :SOFAR))]
MAKE "PEEKTOKEN :TOKEN
OUTPUT LPUT :RESULT :SOFAR
END

TO COMPILE :FILE
LOCAL "ERROR
IF NAMEP "PEEKCHAR [ERN "PEEKCHAR]
IF NAMEP "PEEKTOKEN [ERN "PEEKTOKEN]
OPENREAD :FILE
SETREAD :FILE
IGNORE ERROR
CATCH "ERROR [PROGRAM]
MAKE "ERROR ERROR
IF NOT EMPTYP :ERROR ~
   [IF NOT EQUALP FIRST :ERROR 19 ~
       [PR FIRST BF :ERROR]]
SETREAD []
CLOSE :FILE
END

TO COPYOFARRAY :TARGET
LOCAL [TO FROM]
MAKE "FROM THING FIRST :TARGET
MAKE "TO ARRAY ACOUNT :FROM
FOR [I 0 [(ACOUNT :FROM) - 1]] [PARRAY :TO :I GARRAY :FROM :I]
END

TO FUNCTION
LOCAL [PROGNAME OLDIDLIST ARGLIST TYPE]
LOCAL "CODEINTO
MAKE "PROGNAME TOKEN
PUSH "IDLIST (LIST :PROGNAME "FUNCTION NEWLNAME :PROGNAME)
MAKE "OLDIDLIST :IDLIST
LOCAL "IDLIST
MAKE "IDLIST :OLDIDLIST
MAKE "ARGLIST []
MAKE LNAME :PROGNAME []
IFBE "|(| [ARGLIST]
MUSTBE ":
MAKE "TYPE TOKEN
TYPECHECK :TYPE
MAKE LNAME :PROGNAME FPUT :TYPE THING LNAME :PROGNAME
MUSTBE "|;|
DEFINE LNAME :PROGNAME (LIST :ARGLIST)
MAKE "CODEINTO LNAME :PROGNAME
CODE [LOCAL "RESULT]
PROGRAM1
CODE [OUTPUT :RESULT]
MUSTBE "|;|
END

TO GETCHAR
LOCAL "CHAR
IF NAMEP "PEEKCHAR [MAKE "CHAR :PEEKCHAR ERN "PEEKCHAR OUTPUT :CHAR]
IF EOFP [OUTPUT CHAR 1]
OUTPUT RC1
END

TO GETTYPE :WORD
LOCAL "RESULT
MAKE "RESULT LNAME1 :WORD :IDLIST
IF NOT EMPTYP :RESULT [OUTPUT ITEM 2 :RESULT]
PRINT SE [UNRECOGNIZED IDENTIFIER] :WORD
THROW "ERROR
END

TO ID
LOCAL "TOKEN
MAKE "TOKEN TOKEN
IF LETTERP ASCII FIRST :TOKEN [OUTPUT :TOKEN]
MAKE "PEEKTOKEN :TOKEN
OUTPUT []
END

TO IFBE :WANTED :ACTION
LOCAL "TOKEN
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN :WANTED [RUN :ACTION STOP]
MAKE "PEEKTOKEN :TOKEN
END

TO IFBEELSE :WANTED :ACTION :ELSE
LOCAL "TOKEN
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN :WANTED [RUN :ACTION STOP]
MAKE "PEEKTOKEN :TOKEN
RUN :ELSE
END

TO LETTERP :CODE
IF AND (:CODE > 64) (:CODE < 91) [OUTPUT "TRUE]
OUTPUT AND (:CODE > 96) (:CODE < 123)
END

TO LINDEX :BOUNDS :INDEX
OUTPUT LINDEX1 (OFFSET PINTEGER FIRST :INDEX FIRST FIRST :BOUNDS) ~
               BF :BOUNDS BF :INDEX
END

TO LINDEX1 :SOFAR :BOUNDS :INDEX
IF EMPTYP :BOUNDS [OUTPUT :SOFAR]
OUTPUT LINDEX1 (NEXTINDEX :SOFAR ~
                          LAST FIRST :BOUNDS ~
                          PINTEGER FIRST :INDEX ~
                          FIRST FIRST :BOUNDS) ~
               BF :BOUNDS BF :INDEX
END

TO LNAME :WORD
LOCAL "RESULT
MAKE "RESULT LNAME1 :WORD :IDLIST
IF NOT EMPTYP :RESULT [OUTPUT ITEM 3 :RESULT]
PRINT SE [UNRECOGNIZED IDENTIFIER] :WORD
THROW "ERROR
END

TO LNAME1 :WORD :LIST
IF EMPTYP :LIST [OUTPUT []]
IF EQUALP :WORD FIRST FIRST :LIST [OUTPUT FIRST :LIST]
OUTPUT LNAME1 :WORD BF :LIST
END

TO LPUSH :STACK :STUFF
MAKE :STACK LPUT :STUFF THING :STACK
END

TO MULT :A :B
OUTPUT (SE [( PRODUCT] :A :B [)] )
END

TO MUSTBE :WANTED
LOCAL "TOKEN
MAKE "TOKEN TOKEN
IF EQUALP :TOKEN :WANTED [STOP]
PRINT (SE "EXPECTED :WANTED "GOT :TOKEN)
THROW "ERROR
END

TO NEWARG :PNAME :TYPE :LNAME :VARFLAG
IF RESERVEDP :PNAME [PR SE :PNAME [RESERVED WORD] THROW "ERROR]
PUSH "IDLIST IFELSE :VARFLAG ~
                    [(LIST :PNAME "VAR :LNAME :TYPE)] ~
                    [(LIST :PNAME :TYPE :LNAME)]
LPUSH "ARGLIST :LNAME
LPUSH LNAME :PROGNAME IFELSE :VARFLAG [LIST "VAR :TYPE] [:TYPE]
END

TO NEWLNAME :WORD
IF MEMBERP :WORD :NAMESUSED [OUTPUT GENSYM]
IF NAMEP WORD "% :WORD [OUTPUT GENSYM]
PUSH "NAMESUSED :WORD
OUTPUT WORD "% :WORD
END

TO NEWVAR :PNAME :TYPE :LNAME
IF RESERVEDP :PNAME [PR SE :PNAME [RESERVED WORD] THROW "ERROR]
PUSH "IDLIST (LIST :PNAME :TYPE :LNAME)
CODE LIST "LOCAL WORD "" :LNAME
IF LISTP :TYPE [CODE (LIST "MAKE WORD "" :LNAME "ARRAY ARRAYSIZE :TYPE)]
END

TO NEXTINDEX :OLD :FACTOR :NEW :OFFSET
OUTPUT (SE [( SUM] (MULT :OLD :FACTOR) (OFFSET :NEW :OFFSET) [)] )
END

TO NUMBER :NUM
LOCAL "CHAR
MAKE "CHAR GETCHAR
IF EQUALP :CHAR ". ~
   [MAKE "CHAR GETCHAR ~
    IFELSE EQUALP :CHAR ". ~
           [MAKE "PEEKTOKEN ".. OUTPUT :NUM] ~
           [MAKE "PEEKCHAR :CHAR OUTPUT NUMBER WORD :NUM ".]]
IF EQUALP :CHAR "E [OUTPUT NUMBER WORD :NUM TWOCHAR "E [+ -]]
IF NUMBERP :CHAR [OUTPUT NUMBER WORD :NUM :CHAR]
MAKE "PEEKCHAR :CHAR
OUTPUT :NUM
END

TO NUMTYPE :NUMBER
IF MEMBERP ". :NUMBER [OUTPUT "REAL]
IF MEMBERP "E :NUMBER [OUTPUT "REAL]
OUTPUT "INTEGER
END

TO OFFSET :A :B
OUTPUT (SE [( DIFFERENCE] :A :B [)] )
END

TO OPSETUP
PPROP "|=| "BINARY [EQUALP 2 [BOOLEAN []] 1]
PPROP "|<>| "BINARY [[NOT EQUALP] 2 [BOOLEAN []] 1]
PPROP "|<| "BINARY [LESSP 2 [BOOLEAN []] 1]
PPROP "|>| "BINARY [GREATERP 2 [BOOLEAN []] 1]
PPROP "|<=| "BINARY [[NOT GREATERP] 2 [BOOLEAN []] 1]
PPROP "|>=| "BINARY [[NOT LESSP] 2 [BOOLEAN []] 1]
PPROP "|+| "BINARY [SUM 2 2]
PPROP "|-| "BINARY [DIFFERENCE 2 2]
PPROP "OR "BINARY [OR 2 [BOOLEAN BOOLEAN] 2]
PPROP "|*| "BINARY [PRODUCT 2 3]
PPROP "|/| "BINARY [QUOTIENT 2 [REAL []] 3]
PPROP "DIV "BINARY [[INT QUOTIENT] 2 [INTEGER INTEGER] 3]
PPROP "MOD "BINARY [REMAINDER 2 [INTEGER INTEGER] 3]
PPROP "AND "BINARY [AND 2 [BOOLEAN BOOLEAN] 3]
PPROP "|+| "UNARY [[] 1 4]
PPROP "|-| "UNARY [MINUS 1 4]
PPROP "NOT "UNARY [NOT 1 [BOOLEAN BOOLEAN] 4]
MAKE "IDLIST [[TRUNC FUNCTION INT] ~
              [ROUND FUNCTION ROUND] [RANDOM FUNCTION RANDOM]]
MAKE "INT [INTEGER REAL]
MAKE "ROUND [INTEGER REAL]
MAKE "RANDOM [INTEGER INTEGER]
END

TO PARRAYASSIGN :NAME :TYPE :TARGET
LOCAL [RIGHT RTYPE RLNAME RTARGET]
MAKE "RIGHT TOKEN
IF EQUALP FIRST :RIGHT "' [OUTPUT PSTRINGASSIGN :TARGET :TYPE (BL BF :RIGHT)]
MAKE "RTYPE GETTYPE :RIGHT
MAKE "RLNAME LNAME :RIGHT
IFELSE EQUALP :RTYPE "VAR [PVARRIGHT] [MAKE "RTARGET (LIST :RLNAME)]
IF EQUALP :TYPE :RTYPE [OUTPUT (LIST "ARRAYCOPY :TARGET :RTARGET)]
PR (SE "ARRAYS :NAME "AND :RIGHT [UNEQUAL TYPES])
THROW "ERROR
END

TO PARRAYDATA :PNAME :TYPE :TARGET
LOCAL "INDEX
MUSTBE "|[|
MAKE "INDEX COMMALIST [PEXPR]
MUSTBE "|]|
MAKE "INDEX LINDEX LAST :TYPE :INDEX
MAKE "TYPE FIRST :TYPE
MAKE "TARGET SE :TARGET :INDEX
OUTPUT PMAYBECHAR :TYPE (LIST "PTHING :TARGET)
END

TO PASSIGN
LOCAL [NAME TYPE INDEX VALUE LNAME TARGET]
MAKE "NAME TOKEN
MAKE "IND